# pol models (across performance and neutral)
m1.pol <- readRDS(file = here(pol_model_dir, "m1.pol.rds"))
m2.pol <- readRDS(file = here(pol_model_dir, "m2.pol.rds"))
m3.pol <- readRDS(file = here(pol_model_dir, "m3.pol.rds"))
m4.pol <- readRDS(file = here(pol_model_dir, "m4.pol.rds"))
m5.pol <- readRDS(file = here(pol_model_dir, "m5.pol.rds"))
m6.pol <- readRDS(file = here(pol_model_dir, "m6.pol.rds"))
# performance models
m1.per <- readRDS(file = here(nonpol_model_dir, "m1.per.rds"))
m2.per <- readRDS(file = here(nonpol_model_dir, "m2.per.rds"))
m3.per <- readRDS(file = here(nonpol_model_dir, "m3.per.rds"))
m4.per <- readRDS(file = here(nonpol_model_dir, "m4.per.rds"))
m5.per <- readRDS(file = here(nonpol_model_dir, "m5.per.rds"))
m6.per <- readRDS(file = here(nonpol_model_dir, "m6.per.rds"))
# neutral models
m1.neu <- readRDS(file = here(nonpol_model_dir, "m1.neu.rds"))
m2.neu <- readRDS(file = here(nonpol_model_dir, "m2.neu.rds"))
m3.neu <- readRDS(file = here(nonpol_model_dir, "m3.neu.rds"))
m4.neu <- readRDS(file = here(nonpol_model_dir, "m4.neu.rds"))
m5.neu <- readRDS(file = here(nonpol_model_dir, "m5.neu.rds"))
m6.neu <- readRDS(file = here(nonpol_model_dir, "m6.neu.rds"))Figures and tables based on issue motive analyses (main)
Preparations
Load models
Load original data
data_path <- here("01_data", "analysis", "data_analysis.RData")
load(file = data_path)Filters
initial_rows <- nrow(data_analysis)
data_prep <- data_analysis %>%
filter(Screen != "Question")
filtered_rows <- initial_rows - nrow(data_prep)
filtered_rows[1] 5389
data_full <- data_prep %>%
filter(question_type %in% c("political", "performance", "nonpolitical")) %>%
mutate(question_topic = factor(question_topic,
levels = c("climate",
"gender",
"immigration",
"discrimination",
"adoption",
"punishment",
"gonogo_performance",
"fakenews_performance",
"teaculture",
"brain"))) %>%
droplevels()
unique(data_full$question_topic) [1] adoption climate punishment gender
[5] discrimination gonogo_performance immigration teaculture
[9] fakenews_performance brain
10 Levels: climate gender immigration discrimination adoption ... brain
Data types
data_full <- data_full %>%
mutate(issue_motive_strength = factor(issue_motive_strength,
levels = c("Anti-strong",
"Anti-moderate",
"Neutral",
"Pro-moderate",
"Pro-strong"),
ordered = TRUE)) Data for submodels
data_pol <- data_full %>%
filter(question_type == "political") %>%
droplevels()
data_per <- data_full %>%
filter(question_type == "performance") %>%
droplevels()
data_neu <- data_full %>%
filter(question_type == "nonpolitical") %>%
droplevels()
unique(data_pol$question_topic)[1] adoption climate punishment gender discrimination
[6] immigration
Levels: climate gender immigration discrimination adoption punishment
unique(data_per$question_topic)[1] gonogo_performance fakenews_performance
Levels: gonogo_performance fakenews_performance
unique(data_neu$question_topic)[1] teaculture brain
Levels: teaculture brain
Table 1: Parameter estimates of interest m1, m3, m4 (logit)
Create a logit table with main parameters of interest of m1, m3, m4.
m1 table
h0a.pol <- hypothesis(m1.pol, "issue_motivePro > 0",
alpha = 0.025,
seed = 42)
h0a.per <- hypothesis(m1.per, "issue_motivePro > 0",
alpha = 0.025,
seed = 42)
h0a.neu <- hypothesis(m1.neu, "issue_motivePro > 0",
alpha = 0.025,
seed = 42)
h0a.pol$hypothesis$Evid.Ratio[1] Inf
h0a.per$hypothesis$Evid.Ratio[1] 91
h0a.neu$hypothesis$Evid.Ratio[1] Inf
h0b.pol <- hypothesis(m1.pol, "issue_motivePro < 0",
alpha = 0.025,
seed = 42)
h0b.per <- hypothesis(m1.per, "issue_motivePro < 0",
alpha = 0.025,
seed = 42)
h0b.neu <- hypothesis(m1.neu, "issue_motivePro < 0",
alpha = 0.025,
seed = 42)
h0b.pol$hypothesis$Evid.Ratio[1] 0
h0b.per$hypothesis$Evid.Ratio[1] 0.011
h0b.neu$hypothesis$Evid.Ratio[1] 0
m1.pol.logit <- describe_posterior(m1.pol, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Political") %>%
mutate("β > 0" = h0a.pol$hypothesis$Evid.Ratio,
"β < 0" = h0b.pol$hypothesis$Evid.Ratio)
m1.per.logit <- describe_posterior(m1.per, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Performance") %>%
mutate("β > 0" = h0a.per$hypothesis$Evid.Ratio,
"β < 0" = h0b.per$hypothesis$Evid.Ratio)
m1.neu.logit <- describe_posterior(m1.neu, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Neutral") %>%
mutate("β > 0" = h0a.neu$hypothesis$Evid.Ratio,
"β < 0" = h0b.neu$hypothesis$Evid.Ratio)
m1.logit <- bind_rows(m1.pol.logit, m1.per.logit, m1.neu.logit) %>%
select("Question Type", Parameter, Median,
CI_low, CI_high, "β > 0", "β < 0") %>%
rename("LL" = CI_low,
"UL" = CI_high) %>%
filter(Parameter == "b_issue_motivePro") %>%
mutate(Parameter = "Motive (Pro > Anti)") %>%
mutate(across(where(is.numeric), ~ round(.x, 3)))
m1.logitSummary of Posterior Distribution
Question Type | Parameter | Median | LL | UL | β > 0 | β < 0
--------------------------------------------------------------------------
Political | Motive (Pro > Anti) | 0.36 | 0.26 | 0.47 | Inf | 0.00
Performance | Motive (Pro > Anti) | 0.17 | 0.03 | 0.31 | 90.95 | 0.01
Neutral | Motive (Pro > Anti) | 0.36 | 0.21 | 0.52 | Inf | 0.00
m3 table
h1a.pol <- hypothesis(m3.pol, "issue_motivePro:scalecrt_correct > 0",
alpha = 0.025,
seed = 42)
h1a.per <- hypothesis(m3.per, "issue_motivePro:scalecrt_correct > 0",
alpha = 0.025,
seed = 42)
h1a.neu <- hypothesis(m3.neu, "issue_motivePro:scalecrt_correct > 0",
alpha = 0.025,
seed = 42)
h1a.pol$hypothesis$Evid.Ratio[1] 0.0492
h1a.per$hypothesis$Evid.Ratio[1] 0.499
h1a.neu$hypothesis$Evid.Ratio[1] 0.13
h1b.pol <- hypothesis(m3.pol, "issue_motivePro:scalecrt_correct < 0",
alpha = 0.025,
seed = 42)
h1b.per <- hypothesis(m3.per, "issue_motivePro:scalecrt_correct < 0",
alpha = 0.025,
seed = 42)
h1b.neu <- hypothesis(m3.neu, "issue_motivePro:scalecrt_correct < 0",
alpha = 0.025,
seed = 42)
h1b.pol$hypothesis$Evid.Ratio[1] 20.3
h1b.per$hypothesis$Evid.Ratio[1] 2.01
h1b.neu$hypothesis$Evid.Ratio[1] 7.7
m3.pol.logit <- describe_posterior(m3.pol, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Political") %>%
mutate("β > 0" = h1a.pol$hypothesis$Evid.Ratio,
"β < 0" = h1b.pol$hypothesis$Evid.Ratio)
m3.per.logit <- describe_posterior(m3.per, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Performance") %>%
mutate("β > 0" = h1a.per$hypothesis$Evid.Ratio,
"β < 0" = h1b.per$hypothesis$Evid.Ratio)
m3.neu.logit <- describe_posterior(m3.neu, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Neutral") %>%
mutate("β > 0" = h1a.neu$hypothesis$Evid.Ratio,
"β < 0" = h1b.neu$hypothesis$Evid.Ratio)
m3.logit <- bind_rows(m3.pol.logit, m3.per.logit, m3.neu.logit) %>%
select("Question Type", Parameter, Median,
CI_low, CI_high, "β > 0", "β < 0") %>%
rename("LL" = CI_low,
"UL" = CI_high) %>%
filter(Parameter == "b_issue_motivePro:scalecrt_correct") %>%
mutate(Parameter = "Motive x Cognitive Reflection") %>%
mutate(across(where(is.numeric), ~ round(.x, 3)))
m3.logitSummary of Posterior Distribution
Question Type | Parameter | Median | LL | UL | β > 0 | β < 0
-------------------------------------------------------------------------------------
Political | Motive x Cognitive Reflection | -0.06 | -0.14 | 0.01 | 0.05 | 20.33
Performance | Motive x Cognitive Reflection | -0.03 | -0.18 | 0.12 | 0.50 | 2.00
Neutral | Motive x Cognitive Reflection | -0.10 | -0.26 | 0.06 | 0.13 | 7.70
m4 table
h2a.pol <- hypothesis(m4.pol, "issue_motivePro:scalecommission_errors_r > 0",
alpha = 0.025,
seed = 42)
h2a.per <- hypothesis(m4.per, "issue_motivePro:scalecommission_errors_r > 0",
alpha = 0.025,
seed = 42)
h2a.neu <- hypothesis(m4.neu, "issue_motivePro:scalecommission_errors_r > 0",
alpha = 0.025,
seed = 42)
h2a.pol$hypothesis$Evid.Ratio[1] 2.71
h2a.per$hypothesis$Evid.Ratio[1] 0.191
h2a.neu$hypothesis$Evid.Ratio[1] 63
h2b.pol <- hypothesis(m4.pol, "issue_motivePro:scalecommission_errors_r < 0",
alpha = 0.025,
seed = 42)
h2b.per <- hypothesis(m4.per, "issue_motivePro:scalecommission_errors_r < 0",
alpha = 0.025,
seed = 42)
h2b.neu <- hypothesis(m4.neu, "issue_motivePro:scalecommission_errors_r < 0",
alpha = 0.025,
seed = 42)
h2b.pol$hypothesis$Evid.Ratio[1] 0.368
h2b.per$hypothesis$Evid.Ratio[1] 5.25
h2b.neu$hypothesis$Evid.Ratio[1] 0.0159
m4.pol.logit <- describe_posterior(m4.pol, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Political") %>%
mutate("β > 0" = h2a.pol$hypothesis$Evid.Ratio,
"β < 0" = h2b.pol$hypothesis$Evid.Ratio)
m4.per.logit <- describe_posterior(m4.per, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Performance") %>%
mutate("β > 0" = h2a.per$hypothesis$Evid.Ratio,
"β < 0" = h2b.per$hypothesis$Evid.Ratio)
m4.neu.logit <- describe_posterior(m4.neu, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Neutral") %>%
mutate("β > 0" = h2a.neu$hypothesis$Evid.Ratio,
"β < 0" = h2b.neu$hypothesis$Evid.Ratio)
m4.logit <- bind_rows(m4.pol.logit, m4.per.logit, m4.neu.logit) %>%
select("Question Type", Parameter, Median,
CI_low, CI_high, "β > 0", "β < 0") %>%
rename("LL" = CI_low,
"UL" = CI_high) %>%
filter(Parameter == "b_issue_motivePro:scalecommission_errors_r") %>%
mutate(Parameter = "Motive x Inhibitory Control") %>%
mutate(across(where(is.numeric), ~ round(.x, 3)))
m4.logitSummary of Posterior Distribution
Question Type | Parameter | Median | LL | UL | β > 0 | β < 0
-----------------------------------------------------------------------------------
Political | Motive x Inhibitory Control | 0.02 | -0.05 | 0.10 | 2.71 | 0.37
Performance | Motive x Inhibitory Control | -0.07 | -0.23 | 0.07 | 0.19 | 5.25
Neutral | Motive x Inhibitory Control | 0.17 | 0.01 | 0.33 | 63.00 | 0.02
Combined table
combined_logit <- bind_rows(m1.logit, m3.logit, m4.logit) %>%
mutate(`Question Type` = factor(`Question Type`, levels = c("Political", "Performance", "Neutral"))) %>%
arrange(`Question Type`, Parameter)
combined_logit_table <- combined_logit %>%
select(-c("Question Type")) %>%
tt() %>%
group_tt(
i = list(
"Political Vignettes" = 1,
"Performance Vignettes" = 4,
"Neutral Vignettes" = 7
),
j = list(
"95% CI" = 3:4,
"Evidence Ratio" = 5:6))
combined_logit_table %>% save_tt(here(table_dir, "combined_logit_table.docx"), overwrite = TRUE)
combined_logit_table| 95% CI | Evidence Ratio | ||||
|---|---|---|---|---|---|
| Parameter | Median | LL | UL | β > 0 | β < 0 |
| Motive (Pro > Anti) | 0.363 | 0.258 | 0.475 | Inf | 0.000 |
| Motive x Cognitive Reflection | -0.063 | -0.139 | 0.010 | 0.049 | 20.333 |
| Motive x Inhibitory Control | 0.024 | -0.049 | 0.100 | 2.714 | 0.368 |
| Motive (Pro > Anti) | 0.169 | 0.025 | 0.312 | 90.954 | 0.011 |
| Motive x Cognitive Reflection | -0.033 | -0.180 | 0.116 | 0.499 | 2.005 |
| Motive x Inhibitory Control | -0.075 | -0.232 | 0.075 | 0.191 | 5.245 |
| Motive (Pro > Anti) | 0.361 | 0.209 | 0.517 | Inf | 0.000 |
| Motive x Cognitive Reflection | -0.097 | -0.261 | 0.060 | 0.130 | 7.696 |
| Motive x Inhibitory Control | 0.173 | 0.012 | 0.329 | 63.000 | 0.016 |
Main Text: Reported Percentage Predictions m1, m3
m1: Pro vs. Anti in %
Calculate % comparisons
m1.pol.com <- m1.pol %>%
avg_comparisons() %>%
as_tibble() %>%
select(contrast, estimate, conf.low, conf.high) %>%
filter(contrast == "mean(Pro) - mean(Anti)") %>%
mutate(contrast = recode(contrast,
"mean(Pro) - mean(Anti)" = "Pro - Anti"),
"Question Type" = "Political") %>%
rename("Contrast" = "contrast",
"Estimate" = "estimate",
"LL" = "conf.low",
"UL" = "conf.high")m1.per.com <- m1.per %>%
avg_comparisons() %>%
as_tibble() %>%
select(contrast, estimate, conf.low, conf.high) %>%
filter(contrast == "mean(Pro) - mean(Anti)") %>%
mutate(contrast = recode(contrast,
"mean(Pro) - mean(Anti)" = "Pro - Anti"),
"Question Type" = "Performance") %>%
rename("Contrast" = "contrast",
"Estimate" = "estimate",
"LL" = "conf.low",
"UL" = "conf.high")m1.neu.com <- m1.neu %>%
avg_comparisons() %>%
as_tibble() %>%
select(contrast, estimate, conf.low, conf.high) %>%
filter(contrast == "mean(Pro) - mean(Anti)") %>%
mutate(contrast = recode(contrast,
"mean(Pro) - mean(Anti)" = "Pro - Anti"),
"Question Type" = "Neutral") %>%
rename("Contrast" = "contrast",
"Estimate" = "estimate",
"LL" = "conf.low",
"UL" = "conf.high")Combined table
m1.combined_perc <- bind_rows(m1.pol.com, m1.per.com, m1.neu.com) %>%
mutate(`Question Type` = factor(`Question Type`, levels = c("Political", "Performance", "Neutral")))
m1.combined_perc_table <- m1.combined_perc %>%
select(-c("Question Type")) %>%
tt() %>%
group_tt(
i = list(
"Political Vignettes" = 1,
"Performance Vignettes" = 2,
"Neutral Vignettes" = 3
),
j = list(
"95% CI" = 3:4))
m1.combined_perc_table %>% save_tt(here(table_dir, "m1_combined_perc_table.docx"), overwrite = TRUE)
m1.combined_perc_table| 95% CI | |||
|---|---|---|---|
| Contrast | Estimate | LL | UL |
| Pro - Anti | 0.0923 | 0.0741 | 0.1105 |
| Pro - Anti | 0.0419 | 0.0079 | 0.0757 |
| Pro - Anti | 0.0944 | 0.0571 | 0.1322 |
m3: Pro vs. Anti for CRT = 3 and CRT = 0 in %
crt.newdata <-
expand_grid(issue_motive = c("Pro", "Anti"),
crt_correct = c(0, 3))m3.pol.com <- m3.pol %>%
epred_draws(newdata = crt.newdata,
re_formula = NA) %>%
group_by(crt_correct) %>%
compare_levels(.epred, by = issue_motive) %>%
compare_levels(.epred, by = crt_correct) %>%
median_qi(.width = 0.95)m3.pol.com %>% tt()| crt_correct | issue_motive | .epred | .lower | .upper | .width | .point | .interval |
|---|---|---|---|---|---|---|---|
| 3 - 0 | Pro - Anti | -0.0418 | -0.0922 | 0.00625 | 0.95 | median | qi |
Figure: Motivated Reasoning on Different Topics
Extract draws
Average effect of motivated reasoning on political, performance, and neutral topics
m1.pol.draws <- m1.pol %>%
avg_comparisons(variables = "issue_motive") %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)") %>%
mutate(question_type = "Political",
question_topic = "average")
m1.pol.draws %>% median_hdi(draw)# A tibble: 1 × 6
draw .lower .upper .width .point .interval
<dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 0.0923 0.0746 0.111 0.95 median hdi
m1.per.draws <- m1.per %>%
avg_comparisons(variables = "issue_motive") %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)") %>%
mutate(question_type = "Performance",
question_topic = "average")
m1.per.draws %>% median_hdi(draw)# A tibble: 1 × 6
draw .lower .upper .width .point .interval
<dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 0.0419 0.00833 0.0760 0.95 median hdi
m1.neu.draws <- m1.neu %>%
avg_comparisons(variables = "issue_motive") %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)") %>%
mutate(question_type = "Neutral",
question_topic = "average")
m1.neu.draws %>% median_hdi(draw)# A tibble: 1 × 6
draw .lower .upper .width .point .interval
<dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 0.0944 0.0568 0.132 0.95 median hdi
Motivated reasoning by topic
m1.pol.topic <- avg_comparisons(m1.pol,
variables = "issue_motive",
by = "question_topic") %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)") %>%
mutate(question_type = "Political")
m1.pol.topic %>% group_by(question_topic) %>% median_hdi(draw)# A tibble: 6 × 7
question_topic draw .lower .upper .width .point .interval
<fct> <dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 climate 0.0986 0.0715 0.129 0.95 median hdi
2 gender 0.0918 0.0644 0.119 0.95 median hdi
3 immigration 0.0933 0.0647 0.123 0.95 median hdi
4 discrimination 0.0987 0.0706 0.131 0.95 median hdi
5 adoption 0.0917 0.0644 0.122 0.95 median hdi
6 punishment 0.0798 0.0424 0.110 0.95 median hdi
m1.per.topic <- avg_comparisons(m1.per,
variables = "issue_motive",
by = "question_topic") %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)") %>%
mutate(question_type = "Performance")
m1.per.topic %>% group_by(question_topic) %>% median_hdi(draw)# A tibble: 2 × 7
question_topic draw .lower .upper .width .point .interval
<fct> <dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 gonogo_performance 0.0398 -0.0108 0.0840 0.95 median hdi
2 fakenews_performance 0.0440 -0.00235 0.0955 0.95 median hdi
m1.neu.topic <- avg_comparisons(m1.neu,
variables = "issue_motive",
by = "question_topic") %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)") %>%
mutate(question_type = "Neutral")
m1.neu.topic %>% group_by(question_topic) %>% median_hdi(draw)# A tibble: 2 × 7
question_topic draw .lower .upper .width .point .interval
<fct> <dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 teaculture 0.137 0.0866 0.187 0.95 median hdi
2 brain 0.0442 -0.0121 0.101 0.95 median hdi
Create a combined dataframe
m1.combined <- bind_rows(m1.pol.draws, m1.pol.topic,
m1.per.draws, m1.per.topic,
m1.neu.draws, m1.neu.topic)m1.combined <- m1.combined %>%
mutate(question_topic = factor(question_topic,
levels = c("brain",
"teaculture",
"fakenews_performance",
"gonogo_performance",
"punishment",
"adoption",
"discrimination",
"gender",
"immigration",
"climate",
"average"),
labels = c("Brain proportion",
"Tea with milk",
"Fake News performance",
"Go / No-Go performance",
"Criminal reconviction",
"Same-sex adoption",
"Racial discrimination",
"Gender stereotypes",
"Immigrant population",
"Anthropogenic climate change",
"Average"
)),
draw_perc = draw*100) Create figure
average_color <- "#645CAA"
plot_political <- m1.combined %>%
filter(question_type == "Political") %>%
ggplot(aes(x = draw_perc, y = question_topic,
fill = question_topic == "Average")) +
stat_halfeye(slab_alpha = 0.9, .width = c(0.5, 0.95),
point_interval = "median_qi") +
geom_vline(xintercept = 0, alpha = 0.8, linewidth = 0.8,
color = "black", linetype = "dashed") +
scale_fill_manual(values = c(`TRUE` = average_color, `FALSE` = "#A685E2")) +
labs(subtitle = "Political Vignettes",
x = NULL, y = NULL) +
scale_x_continuous(labels = label_percent(scale = 1), limits = c(-10, 25),
breaks = seq(-10, 20, by = 5)) +
theme_ipsum_rc(base_size = 16,
subtitle_size = 18,
subtitle_face = "bold",
axis_text_size = 16,
grid = "XY") +
guides(fill = "none") +
theme(legend.position = "none")
plot_performance <- m1.combined %>%
filter(question_type == "Performance") %>%
ggplot(aes(x = draw_perc, y = question_topic,
fill = question_topic == "Average")) +
stat_halfeye(slab_alpha = 0.9, .width = c(0.5, 0.95),
point_interval = "median_qi") +
geom_vline(xintercept = 0, alpha = 0.8, linewidth = 0.8,
color = "black", linetype = "dashed") +
scale_fill_manual(values = c(`TRUE` = average_color, `FALSE` = "#FF8DC7")) +
labs(subtitle = "Performance Vignettes",
x = NULL, y = NULL) +
scale_x_continuous(labels = label_percent(scale = 1), limits = c(-10, 25)) +
theme_ipsum_rc(base_size = 16,
subtitle_size = 18,
subtitle_face = "bold",
axis_text_size = 16,
grid = "XY") +
guides(fill = "none") +
theme(legend.position = "none")
plot_neutral <- m1.combined %>%
filter(question_type == "Neutral") %>%
ggplot(aes(x = draw_perc, y = question_topic,
fill = question_topic == "Average")) +
stat_halfeye(slab_alpha = 0.9, .width = c(0.5, 0.95),
point_interval = "median_qi") +
geom_vline(xintercept = 0, alpha = 0.8, linewidth = 0.8,
color = "black", linetype = "dashed") +
scale_fill_manual(values = c(`TRUE` = average_color, `FALSE` = "#FFABE1")) +
labs(subtitle = "Neutral Vignettes",
x = NULL, y = NULL) +
scale_x_continuous(labels = label_percent(scale = 1), limits = c(-10, 25)) +
theme_ipsum_rc(base_size = 16,
subtitle_size = 18,
subtitle_face = "bold",
axis_text_size = 16,
grid = "XY") +
guides(fill = "none") +
theme(legend.position = "none")
main_effect_plot <- plot_political / (plot_performance | plot_neutral) +
plot_layout(heights = c(2, 1))
main_effect_plotggsave(here(fig_dir, "m1_main_fig.png"), width = 12, height = 10, dpi = 300)Figure: The link to cognitive control variables
Extract political draws
m3.pol.draws <- avg_comparisons(m3.pol,
variables = "issue_motive",
by = "crt_correct") %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)")
m3.pol.draws %>% group_by(crt_correct) %>% median_hdi(draw)# A tibble: 4 × 7
crt_correct draw .lower .upper .width .point .interval
<dbl> <dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 0 0.115 0.0834 0.147 0.95 median hdi
2 1 0.101 0.0779 0.122 0.95 median hdi
3 2 0.0878 0.0677 0.109 0.95 median hdi
4 3 0.0738 0.0458 0.102 0.95 median hdi
m4.pol.draws <- avg_comparisons(m4.pol,
variables = "issue_motive",
by = "commission_errors_r",
newdata = expand_grid(issue_motive = c("Pro", "Anti"),
commission_errors_r = seq(13, 56)),
re_formula = NA) %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)") Warning: The `issue_motive` variable is treated as a categorical (factor) variable, but
the original data is of class character. It is safer and faster to convert such
variables to factor before fitting the model and calling a `marginaleffects`
function.
This warning appears once per session.
m4.pol.draws %>% group_by(commission_errors_r) %>% median_hdi(draw)# A tibble: 44 × 7
commission_errors_r draw .lower .upper .width .point .interval
<int> <dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 13 0.0759 0.0108 0.137 0.95 median hdi
2 14 0.0767 0.0161 0.138 0.95 median hdi
3 15 0.0775 0.0176 0.135 0.95 median hdi
4 16 0.0781 0.0211 0.135 0.95 median hdi
5 17 0.0788 0.0234 0.133 0.95 median hdi
6 18 0.0796 0.0259 0.132 0.95 median hdi
7 19 0.0803 0.0304 0.133 0.95 median hdi
8 20 0.0810 0.0327 0.131 0.95 median hdi
9 21 0.0817 0.0343 0.128 0.95 median hdi
10 22 0.0825 0.0374 0.128 0.95 median hdi
# ℹ 34 more rows
Create political figures
pol_crt_plot <- m3.pol.draws %>%
mutate(draw_perc = draw * 100) %>%
ggplot(aes(x = crt_correct, y = draw_perc, fill = factor(crt_correct))) +
stat_slabinterval(aes(ymin = conf.low * 100, ymax = conf.high * 100),
.width = c(0.5, 0.95),
alpha = 0.7,
position = position_dodge(width = 0.5)) +
scale_fill_manual(values = c("#E1AFD1", "#AD88C6", "#7469B6", "#6A2C70")) +
labs(title = "Cognitive Reflection and Motivated Reasoning",
subtitle = glue("Political vignettes (Evid.Ratio H1a > H1b = {round(h1a.pol$hypothesis$Evid.Ratio, 2)})"),
x = "Cognitive Reflection",
y = "Motivated Reasoning") +
scale_x_continuous(breaks = c(0, 1, 2, 3)) +
scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
labels = percent_format(scale = 1)) +
theme_ipsum_rc(base_size = 14,
plot_title_size = 16,
plot_title_face = "bold",
axis_title_size = 14,
axis_text_size = 14,
grid = "XY") +
theme(legend.position = "none")
pol_crt_plotalt_pol_crt_plot <- m3.pol.draws %>%
mutate(draw_perc = draw * 100) %>%
ggplot(aes(x = crt_correct, y = draw_perc)) +
stat_lineribbon(.width = c(0.5, 0.95), alpha = 0.6) +
scale_fill_manual(values = c("#AD88C6", "#7469B6")) +
labs(title = "Cognitive Reflection and Motivated Reasoning",
subtitle = glue("Political vignettes (Evid.Ratio H2a > H2b = {round(h1a.pol$hypothesis$Evid.Ratio, 2)})"),
x = "Cognitive Reflection",
y = "Motivated Reasoning",
fill = "Credible interval") +
scale_x_continuous(breaks = c(0, 1, 2, 3)) +
scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
labels = percent_format(scale = 1)) +
theme_ipsum_rc(base_size = 14,
plot_title_size = 16,
plot_title_face = "bold",
axis_title_size = 14,
axis_text_size = 14,
grid = "XY"
) +
theme(legend.position = "top")
alt_pol_crt_plotpol_gng_plot <- m4.pol.draws %>%
mutate(draw_perc = draw * 100) %>%
ggplot(aes(x = commission_errors_r, y = draw_perc)) +
stat_lineribbon(.width = c(0.5, 0.95), alpha = 0.6) +
scale_fill_manual(values = c("#AD88C6", "#7469B6")) +
labs(title = "Inhibitory Control and Motivated Reasoning",
subtitle = glue("Political vignettes (Evid.Ratio H2a > H2b = {round(h2a.pol$hypothesis$Evid.Ratio, 2)})"),
x = "Inhibitory Control",
y = "Motivated Reasoning",
fill = "Credible interval") +
scale_x_continuous(breaks = seq(15, 55, by = 10)) +
scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
labels = percent_format(scale = 1)) +
theme_ipsum_rc(base_size = 14,
plot_title_size = 16,
plot_title_face = "bold",
axis_title_size = 14,
axis_text_size = 14,
grid = "XY"
) +
theme(legend.position = "top")
pol_gng_plotExtract performance and neutral draws
m3.per.draws <- avg_comparisons(m3.per,
variables = "issue_motive",
by = "crt_correct") %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)")
m3.per.draws %>% group_by(crt_correct) %>% median_hdi(draw)# A tibble: 4 × 7
crt_correct draw .lower .upper .width .point .interval
<dbl> <dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 2.22e-16 0.0525 -0.00789 0.112 0.95 median hdi
2 1 e+ 0 0.0477 0.00366 0.0963 0.95 median hdi
3 2 e+ 0 0.0358 -0.00619 0.0763 0.95 median hdi
4 3 e+ 0 0.0339 -0.0197 0.0903 0.95 median hdi
m3.neu.draws <- avg_comparisons(m3.neu,
variables = "issue_motive",
by = "crt_correct") %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)")
m3.neu.draws %>% group_by(crt_correct) %>% median_hdi(draw)# A tibble: 4 × 7
crt_correct draw .lower .upper .width .point .interval
<dbl> <dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 0 0.129 0.0655 0.195 0.95 median hdi
2 1 0.108 0.0606 0.151 0.95 median hdi
3 2 0.0852 0.0410 0.127 0.95 median hdi
4 3 0.0650 0.00509 0.127 0.95 median hdi
m4.per.draws <- avg_comparisons(m4.per,
variables = "issue_motive",
by = "commission_errors_r",
newdata = expand_grid(issue_motive = c("Pro", "Anti"),
commission_errors_r = seq(13, 56),
question_topic = levels(data_per$question_topic)),
re_formula = NA) %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)")
m4.per.draws %>% group_by(commission_errors_r) %>% median_hdi(draw)# A tibble: 44 × 7
commission_errors_r draw .lower .upper .width .point .interval
<int> <dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 13 0.0992 -0.0152 0.217 0.95 median hdi
2 14 0.0971 -0.0149 0.209 0.95 median hdi
3 15 0.0949 -0.0128 0.203 0.95 median hdi
4 16 0.0929 -0.0107 0.196 0.95 median hdi
5 17 0.0908 -0.00827 0.190 0.95 median hdi
6 18 0.0886 -0.00711 0.183 0.95 median hdi
7 19 0.0865 -0.00369 0.178 0.95 median hdi
8 20 0.0842 -0.00266 0.171 0.95 median hdi
9 21 0.0819 -0.00112 0.165 0.95 median hdi
10 22 0.0796 0.00161 0.159 0.95 median hdi
# ℹ 34 more rows
m4.neu.draws <- avg_comparisons(m4.neu,
variables = "issue_motive",
by = "commission_errors_r",
newdata = expand_grid(issue_motive = c("Pro", "Anti"),
commission_errors_r = seq(13, 56),
question_topic = levels(data_neu$question_topic)),
re_formula = NA) %>%
posterior_draws() %>%
filter(contrast == "mean(Pro) - mean(Anti)")
m4.neu.draws %>% group_by(commission_errors_r) %>% median_hdi(draw)# A tibble: 44 × 7
commission_errors_r draw .lower .upper .width .point .interval
<int> <dbl> <dbl> <dbl> <dbl> <chr> <chr>
1 13 -0.0353 -0.155 0.0863 0.95 median hdi
2 14 -0.0300 -0.149 0.0837 0.95 median hdi
3 15 -0.0247 -0.135 0.0893 0.95 median hdi
4 16 -0.0193 -0.126 0.0889 0.95 median hdi
5 17 -0.0140 -0.117 0.0904 0.95 median hdi
6 18 -0.00864 -0.107 0.0915 0.95 median hdi
7 19 -0.00318 -0.0979 0.0923 0.95 median hdi
8 20 0.00223 -0.0885 0.0934 0.95 median hdi
9 21 0.00764 -0.0771 0.0966 0.95 median hdi
10 22 0.0130 -0.0683 0.0967 0.95 median hdi
# ℹ 34 more rows
Create performance and neutral figures
per_crt_plot <- m3.per.draws %>%
mutate(draw_perc = draw * 100) %>%
ggplot(aes(x = crt_correct, y = draw_perc, fill = factor(crt_correct))) +
stat_slabinterval(aes(ymin = conf.low * 100, ymax = conf.high * 100),
.width = c(0.5, 0.95),
alpha = 0.7,
position = position_dodge(width = 0.5)) +
scale_fill_manual(values = c("#E1AFD1", "#AD88C6", "#7469B6", "#6A2C70")) +
labs(subtitle = glue("Performance vignettes
(Evid.Ratio H1a > H1b = {round(h1a.per$hypothesis$Evid.Ratio, 2)})"),
x = NULL,
y = NULL) +
scale_x_continuous(breaks = c(0, 1, 2, 3)) +
scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
labels = percent_format(scale = 1)) +
theme_ipsum_rc(base_size = 14,
plot_title_size = 16,
axis_title_size = 14,
axis_text_size = 14,
grid = "XY") +
theme(legend.position = "none")
per_crt_plotalt_per_crt_plot <- m3.per.draws %>%
mutate(draw_perc = draw * 100) %>%
ggplot(aes(x = crt_correct, y = draw_perc)) +
stat_lineribbon(.width = c(0.5, 0.95), alpha = 0.6) +
scale_fill_manual(values = c("#AD88C6", "#7469B6")) +
labs(subtitle = glue("Performance vignettes
(Evid.Ratio H1a > H1b = {round(h1a.per$hypothesis$Evid.Ratio, 2)})"),
x = NULL,
y = NULL) +
scale_x_continuous(breaks = c(0, 1, 2, 3)) +
scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
labels = percent_format(scale = 1)) +
theme_ipsum_rc(base_size = 14,
plot_title_size = 16,
axis_title_size = 14,
axis_text_size = 14,
grid = "XY") +
theme(legend.position = "none")
alt_per_crt_plotneu_crt_plot <- m3.neu.draws %>%
mutate(draw_perc = draw * 100) %>%
ggplot(aes(x = crt_correct, y = draw_perc, fill = factor(crt_correct))) +
stat_slabinterval(aes(ymin = conf.low * 100, ymax = conf.high * 100),
.width = c(0.5, 0.95),
alpha = 0.7,
position = position_dodge(width = 0.5)) +
scale_fill_manual(values = c("#E1AFD1", "#AD88C6", "#7469B6", "#6A2C70")) +
labs(subtitle = glue("Neutral vignettes
(Evid.Ratio H1a > H1b = {round(h1a.neu$hypothesis$Evid.Ratio, 2)})"),
x = NULL,
y = NULL) +
scale_x_continuous(breaks = c(0, 1, 2, 3)) +
scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
labels = percent_format(scale = 1)) +
theme_ipsum_rc(base_size = 14,
plot_title_size = 16,
axis_title_size = 14,
axis_text_size = 14,
grid = "XY") +
theme(legend.position = "none")
neu_crt_plotper_gng_plot <- m4.per.draws %>%
mutate(draw_perc = draw * 100) %>%
ggplot(aes(x = commission_errors_r, y = draw_perc)) +
stat_lineribbon(.width = c(0.5, 0.95), alpha = 0.6) +
scale_fill_manual(values = c("#AD88C6", "#7469B6")) +
labs(subtitle = glue("Performance vignettes
(Evid.Ratio H2a > H2b = {round(h2a.per$hypothesis$Evid.Ratio, 2)})"),
x = NULL,
y = NULL) +
scale_x_continuous(breaks = seq(15, 55, by = 10)) +
scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
labels = percent_format(scale = 1)) +
theme_ipsum_rc(base_size = 14,
plot_title_size = 16,
axis_title_size = 14,
axis_text_size = 14,
grid = "XY"
) +
theme(legend.position = "none")
per_gng_plotneu_gng_plot <- m4.neu.draws %>%
mutate(draw_perc = draw * 100) %>%
ggplot(aes(x = commission_errors_r, y = draw_perc)) +
stat_lineribbon(.width = c(0.5, 0.95), alpha = 0.6) +
scale_fill_manual(values = c("#AD88C6", "#7469B6")) +
labs(subtitle = glue("Neutral vignettes
(Evid.Ratio H2a > H2b = {round(h2a.neu$hypothesis$Evid.Ratio, 2)})"),
x = NULL,
y = NULL) +
scale_x_continuous(breaks = seq(15, 55, by = 10)) +
scale_y_continuous(breaks = c(-5, 0, 5, 10, 15, 20, 25),
labels = percent_format(scale = 1)) +
theme_ipsum_rc(base_size = 14,
plot_title_size = 16,
axis_title_size = 14,
axis_text_size = 14,
grid = "XY"
) +
theme(legend.position = "none")
neu_gng_plotCombined plot
top_panel <- pol_crt_plot + pol_gng_plot +
plot_layout(ncol = 2, widths = c(1, 1))
bottom_left <- per_crt_plot + neu_crt_plot +
plot_layout(heights = c(1, 1), widths = c(0.5, 0.5))
bottom_right <- per_gng_plot + neu_gng_plot +
plot_layout(heights = c(1, 1), widths = c(1.5, 1.5))
cognitive_plot <- (top_panel / (bottom_left | bottom_right)) +
plot_layout(heights = c(1.5, 2))
cognitive_plotggsave(here(fig_dir, "cognitive_fig.png"), width = 12, height = 10, dpi = 300)Supplementary Table 3
Create a logit table with main parameters of interest of m2, m5, m6.
m2 table
h0a_mo.pol <- as_tibble(m2.pol) %>%
hypothesis(., "bsp_moissue_motive_strength > 0",
alpha = 0.025,
seed = 42)
h0a_mo.per <- as_tibble(m2.per) %>%
hypothesis(., "bsp_moissue_motive_strength > 0",
alpha = 0.025,
seed = 42)
h0a_mo.neu <- as_tibble(m2.neu) %>%
hypothesis(., "bsp_moissue_motive_strength > 0",
alpha = 0.025,
seed = 42)
h0a_mo.pol$hypothesis$Evid.Ratio[1] Inf
h0a_mo.per$hypothesis$Evid.Ratio[1] 399
h0a_mo.neu$hypothesis$Evid.Ratio[1] Inf
h0b_mo.pol <- as_tibble(m2.pol) %>%
hypothesis(., "bsp_moissue_motive_strength < 0",
alpha = 0.025,
seed = 42)
h0b_mo.per <- as_tibble(m2.per) %>%
hypothesis(., "bsp_moissue_motive_strength < 0",
alpha = 0.025,
seed = 42)
h0b_mo.neu <- as_tibble(m2.neu) %>%
hypothesis(., "bsp_moissue_motive_strength < 0",
alpha = 0.025,
seed = 42)
h0b_mo.pol$hypothesis$Evid.Ratio[1] 0
h0b_mo.per$hypothesis$Evid.Ratio[1] 0.00251
h0b_mo.neu$hypothesis$Evid.Ratio[1] 0
m2.pol.logit <- describe_posterior(m2.pol, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Political") %>%
mutate("β > 0" = h0a_mo.pol$hypothesis$Evid.Ratio,
"β < 0" = h0b_mo.pol$hypothesis$Evid.Ratio)
m2.per.logit <- describe_posterior(m2.per, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Performance") %>%
mutate("β > 0" = h0a_mo.per$hypothesis$Evid.Ratio,
"β < 0" = h0b_mo.per$hypothesis$Evid.Ratio)
m2.neu.logit <- describe_posterior(m2.neu, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Neutral") %>%
mutate("β > 0" = h0a_mo.neu$hypothesis$Evid.Ratio,
"β < 0" = h0b_mo.neu$hypothesis$Evid.Ratio)
m2.logit <- bind_rows(m2.pol.logit, m2.per.logit, m2.neu.logit) %>%
select("Question Type", Parameter, Median,
CI_low, CI_high, "β > 0", "β < 0") %>%
rename("LL" = CI_low,
"UL" = CI_high) %>%
filter(Parameter == "bsp_moissue_motive_strength") %>%
mutate(Parameter = "Motive strength") %>%
mutate(across(where(is.numeric), ~ round(.x, 3)))
m2.logitSummary of Posterior Distribution
Question Type | Parameter | Median | LL | UL | β > 0 | β < 0
--------------------------------------------------------------------------
Political | Motive strength | 0.12 | 0.09 | 0.15 | Inf | 0.00
Performance | Motive strength | 0.12 | 0.03 | 0.22 | 399.00 | 3.00e-03
Neutral | Motive strength | 0.13 | 0.07 | 0.19 | Inf | 0.00
m5 table
h1a_mo.pol <- as_tibble(m5.pol) %>%
hypothesis(., "bsp_moissue_motive_strength:scalecrt_correct > 0",
alpha = 0.025,
seed = 42)
h1a_mo.per <- as_tibble(m5.per) %>%
hypothesis(., "bsp_moissue_motive_strength:scalecrt_correct > 0",
alpha = 0.025,
seed = 42)
h1a_mo.neu <- as_tibble(m5.neu) %>%
hypothesis(., "bsp_moissue_motive_strength:scalecrt_correct > 0",
alpha = 0.025,
seed = 42)
h1a_mo.pol$hypothesis$Evid.Ratio[1] 0.0382
h1a_mo.per$hypothesis$Evid.Ratio[1] 0.315
h1a_mo.neu$hypothesis$Evid.Ratio[1] 0.321
h1b_mo.pol <- as_tibble(m5.pol) %>%
hypothesis(., "bsp_moissue_motive_strength:scalecrt_correct < 0",
alpha = 0.025,
seed = 42)
h1b_mo.per <- as_tibble(m5.per) %>%
hypothesis(., "bsp_moissue_motive_strength:scalecrt_correct < 0",
alpha = 0.025,
seed = 42)
h1b_mo.neu <- as_tibble(m5.neu) %>%
hypothesis(., "bsp_moissue_motive_strength:scalecrt_correct < 0",
alpha = 0.025,
seed = 42)
h1b_mo.pol$hypothesis$Evid.Ratio[1] 26.2
h1b_mo.per$hypothesis$Evid.Ratio[1] 3.18
h1b_mo.neu$hypothesis$Evid.Ratio[1] 3.12
m5.pol.logit <- describe_posterior(m5.pol, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Political") %>%
mutate("β > 0" = h1a_mo.pol$hypothesis$Evid.Ratio,
"β < 0" = h1b_mo.pol$hypothesis$Evid.Ratio)
m5.per.logit <- describe_posterior(m5.per, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Performance") %>%
mutate("β > 0" = h1a_mo.per$hypothesis$Evid.Ratio,
"β < 0" = h1b_mo.per$hypothesis$Evid.Ratio)
m5.neu.logit <- describe_posterior(m5.neu, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Neutral") %>%
mutate("β > 0" = h1a_mo.neu$hypothesis$Evid.Ratio,
"β < 0" = h1b_mo.neu$hypothesis$Evid.Ratio)
m5.logit <- bind_rows(m5.pol.logit, m5.per.logit, m5.neu.logit) %>%
select("Question Type", Parameter, Median,
CI_low, CI_high, "β > 0", "β < 0") %>%
rename("LL" = CI_low,
"UL" = CI_high) %>%
filter(Parameter == "bsp_moissue_motive_strength:scalecrt_correct") %>%
mutate(Parameter = "Motive strength x Cognitive Reflection") %>%
mutate(across(where(is.numeric), ~ round(.x, 3)))
m5.logitSummary of Posterior Distribution
Question Type | Parameter | Median | LL | UL | β > 0 | β < 0
--------------------------------------------------------------------------------------------------
Political | Motive strength x Cognitive Reflection | -0.02 | -0.05 | 2.00e-03 | 0.04 | 26.21
Performance | Motive strength x Cognitive Reflection | -0.02 | -0.10 | 0.04 | 0.32 | 3.17
Neutral | Motive strength x Cognitive Reflection | -0.02 | -0.07 | 0.04 | 0.32 | 3.12
m6 table
h2a_mo.pol <- as_tibble(m6.pol) %>%
hypothesis(., "bsp_moissue_motive_strength:scalecommission_errors_r > 0",
alpha = 0.025,
seed = 42)
h2a_mo.per <- as_tibble(m6.per) %>%
hypothesis(., "bsp_moissue_motive_strength:scalecommission_errors_r > 0",
alpha = 0.025,
seed = 42)
h2a_mo.neu <- as_tibble(m6.neu) %>%
hypothesis(., "bsp_moissue_motive_strength:scalecommission_errors_r > 0",
alpha = 0.025,
seed = 42)
h2a_mo.pol$hypothesis$Evid.Ratio[1] 3.55
h2a_mo.per$hypothesis$Evid.Ratio[1] 0.429
h2a_mo.neu$hypothesis$Evid.Ratio[1] 95.4
h2b_mo.pol <- as_tibble(m6.pol) %>%
hypothesis(., "bsp_moissue_motive_strength:scalecommission_errors_r < 0",
alpha = 0.025,
seed = 42)
h2b_mo.per <- as_tibble(m6.per) %>%
hypothesis(., "bsp_moissue_motive_strength:scalecommission_errors_r < 0",
alpha = 0.025,
seed = 42)
h2b_mo.neu <- as_tibble(m6.neu) %>%
hypothesis(., "bsp_moissue_motive_strength:scalecommission_errors_r < 0",
alpha = 0.025,
seed = 42)
h2b_mo.pol$hypothesis$Evid.Ratio[1] 0.282
h2b_mo.per$hypothesis$Evid.Ratio[1] 2.33
h2b_mo.neu$hypothesis$Evid.Ratio[1] 0.0105
m6.pol.logit <- describe_posterior(m6.pol, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Political") %>%
mutate("β > 0" = h2a_mo.pol$hypothesis$Evid.Ratio,
"β < 0" = h2b_mo.pol$hypothesis$Evid.Ratio)
m6.per.logit <- describe_posterior(m6.per, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Performance") %>%
mutate("β > 0" = h2a_mo.per$hypothesis$Evid.Ratio,
"β < 0" = h2b_mo.per$hypothesis$Evid.Ratio)
m6.neu.logit <- describe_posterior(m6.neu, centrality = "median",
ci = 0.95, ci_method = "eti",
diagnostic = c("Rhat"), effects = c("fixed"),
dispersion = FALSE, test = NULL) %>%
mutate("Question Type" = "Neutral") %>%
mutate("β > 0" = h2a_mo.neu$hypothesis$Evid.Ratio,
"β < 0" = h2a_mo.neu$hypothesis$Evid.Ratio)
m6.logit <- bind_rows(m6.pol.logit, m6.per.logit, m6.neu.logit) %>%
select("Question Type", Parameter, Median,
CI_low, CI_high, "β > 0", "β < 0") %>%
rename("LL" = CI_low,
"UL" = CI_high) %>%
filter(Parameter == "bsp_moissue_motive_strength:scalecommission_errors_r") %>%
mutate(Parameter = "Motive strength x Inhibitory Control") %>%
mutate(across(where(is.numeric), ~ round(.x, 3)))
m6.logitSummary of Posterior Distribution
Question Type | Parameter | Median | LL | UL | β > 0 | β < 0
----------------------------------------------------------------------------------------------
Political | Motive strength x Inhibitory Control | 9.00e-03 | -0.01 | 0.03 | 3.55 | 0.28
Performance | Motive strength x Inhibitory Control | -0.02 | -0.08 | 0.06 | 0.43 | 2.33
Neutral | Motive strength x Inhibitory Control | 0.06 | 0.01 | 0.12 | 95.39 | 95.39
Combined table
combined_mo_logit <- bind_rows(m2.logit, m5.logit, m6.logit) %>%
mutate(`Question Type` = factor(`Question Type`, levels = c("Political", "Performance", "Neutral"))) %>%
arrange(`Question Type`, Parameter)
combined_mo_logit_table <- combined_mo_logit %>%
select(-c("Question Type")) %>%
tt() %>%
group_tt(
i = list(
"Political Vignettes" = 1,
"Performance Vignettes" = 4,
"Neutral Vignettes" = 7
),
j = list(
"95% CI" = 3:4,
"Evidence Ratio" = 5:6))
combined_mo_logit_table %>% save_tt(here(table_dir, "combined_mo_logit_table.docx"), overwrite = TRUE)
combined_mo_logit_table| 95% CI | Evidence Ratio | ||||
|---|---|---|---|---|---|
| Parameter | Median | LL | UL | β > 0 | β < 0 |
| Motive strength | 0.118 | 0.085 | 0.151 | Inf | 0.000 |
| Motive strength x Cognitive Reflection | -0.022 | -0.048 | 0.002 | 0.038 | 26.211 |
| Motive strength x Inhibitory Control | 0.009 | -0.015 | 0.034 | 3.548 | 0.282 |
| Motive strength | 0.123 | 0.030 | 0.224 | 399.000 | 0.003 |
| Motive strength x Cognitive Reflection | -0.022 | -0.102 | 0.039 | 0.315 | 3.175 |
| Motive strength x Inhibitory Control | -0.017 | -0.079 | 0.062 | 0.429 | 2.331 |
| Motive strength | 0.126 | 0.072 | 0.190 | Inf | 0.000 |
| Motive strength x Cognitive Reflection | -0.019 | -0.074 | 0.038 | 0.321 | 3.119 |
| Motive strength x Inhibitory Control | 0.063 | 0.010 | 0.122 | 95.386 | 95.386 |
Supplementary Figure 2
Extract draws
m2.pol.draws <- m2.pol %>%
epred_draws(newdata = expand_grid(issue_motive_strength = c("Anti-strong",
"Anti-moderate",
"Neutral",
"Pro-moderate",
"Pro-strong"),
question_topic = levels(data_pol$question_topic)),
re_formula = ~(issue_motive|question_topic))
m2.per.draws <- m2.per %>%
epred_draws(newdata = expand_grid(issue_motive_strength = c("Anti-strong",
"Anti-moderate",
"Neutral",
"Pro-moderate",
"Pro-strong"),
question_topic = levels(data_per$question_topic)),
re_formula = NA)
m2.neu.draws <- m2.neu %>%
epred_draws(newdata = expand_grid(issue_motive_strength = c("Anti-strong",
"Anti-moderate",
"Neutral",
"Pro-moderate",
"Pro-strong"),
question_topic = levels(data_neu$question_topic)),
re_formula = NA) m2.draws <- bind_rows(m2.pol.draws, m2.per.draws, m2.neu.draws) %>%
mutate(issue_motive_strength = factor(issue_motive_strength,
levels = c("Anti-strong",
"Anti-moderate",
"Neutral",
"Pro-moderate",
"Pro-strong"),
ordered = TRUE),
question_topic = factor(question_topic,
levels = c("climate",
"immigration",
"gender",
"discrimination",
"adoption",
"punishment",
"gonogo_performance",
"fakenews_performance",
"teaculture",
"brain"),
labels = c("Anthropogenic climate change",
"Immigrant population",
"Gender stereotypes",
"Racial discrimination",
"Same-sex adoption",
"Criminal reconviction",
"Go / No-Go performance",
"Fake News performance",
"Tea with milk",
"Brain proportion")))Create figure
m2.draws %>%
mutate(perc = .epred * 100) %>%
ggplot(aes(x = perc, y = issue_motive_strength, fill = issue_motive_strength)) +
stat_halfeye(slab_alpha = 0.9, .width = c(0.5, 0.95),
point_interval = "median_qi") +
geom_vline(xintercept = 50, alpha = 0.8, linewidth = 0.8,
color = "black", linetype = "dashed") +
guides(fill = "none") +
scale_fill_manual(values = rev(beyonce_palette(41, n = 5,
type = "continuous"))) +
labs(title="Message Ratings by Motive Strength",
x = "Coefficients", y = NULL,
caption = "50% and 95% credible intervals shown in black") +
scale_x_continuous(labels = label_percent(scale = 1), limits = c(25, 75),
breaks = seq(30, 70, by = 10)) +
theme_ipsum_rc(base_size = 12,
plot_title_size = 14,
axis_title_size = 12,
axis_title_face = "bold",
axis_text_size = 12,
strip_text_size = 12,
strip_text_face = "bold"
) +
facet_wrap(~question_topic, ncol = 2)ggsave(here(fig_dir, "m2_perc_fig.png"), width = 8, height = 12, dpi = 300)